home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Gold Medal Software 3
/
Gold Medal Software - Volume 3 (Gold Medal) (1994).iso
/
bbsutils
/
bgfax120.arj
/
SOURCE.ARJ
/
MAKEFAX.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-03-24
|
10KB
|
391 lines
program
test;
{$R+}
uses
dos, crt;
{$i faxatree.pas}
const
base2 : array[1..13] of word =
(1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096);
base2r : array[1..8] of byte = (128, 64, 32, 16, 8, 4, 2, 1);
maxoutbuf = 8192;
maxfontbuf = 8192;
type
pcxrec = record
zsoft : byte;
version : byte;
encoding : byte;
bitpix : byte;
dimens : array[1..4] of word;
hres : word;
vres : word;
palette : array[1..48] of byte;
reserved : byte;
planes : byte;
byteline : word;
paltype : word;
xssize : word;
yssize : word;
filler : array[1..54] of byte;
end;
zfaxhead = record
header : array[1..5] of char;
offset : byte;
version : word;
reserved : word;
pgwidth : word;
pgcount : word;
coding : word;
end;
fontsettype = array[0..maxfontbuf] of byte;
var
io, v, j, r, c, lines, p, bytesread, pcxbufp, outbufbit, outbufbyte : word;
tf : text;
pcxfile, outfile, fontfile : file;
pcx : pcxrec;
zfax : zfaxhead;
pcxbuf : array[1..8192] of byte;
outbuf : array[1..maxoutbuf] of byte;
imagebuf : array[1..216] of byte;
fontptr : array[0..255] of word;
regs : registers;
endofpage : boolean;
fontset : ^fontsettype;
sarray : array[1..108] of byte;
slen : byte;
tlines : word;
fn, fopen : string[79];
procedure fatal(s : string);
begin
writeln;
writeln(#7'Fatal Error: '+s);
halt(1);
end;
procedure loadingblock;
begin
if tlines = 65535 then begin {display only on PCX conversion}
clreol;
write(#13'[', filepos(pcxfile) div 1024, 'K] Memory [', memavail div 1024,
'K] Scan Lines [', lines, ']'#13);
end;
end;
procedure putoutbit(b : byte);
var
zz : word;
begin
inc(outbufbit);
if outbufbit > 8 then begin
inc(outbufbyte);
outbufbit := 1;
if outbufbyte > maxoutbuf then begin
blockwrite(outfile, outbuf, sizeof(outbuf), zz);
fillchar(outbuf, sizeof(outbuf), #0);
outbufbyte := 1;
end;
end;
if b = 1 then
outbuf[outbufbyte] := outbuf[outbufbyte] xor base2[outbufbit]
end;
procedure addtostream(token : word; color : boolean);
var
i : byte;
begin
if color then begin
for i := 1 to whitea[token][0] do begin
if (whitea[token][1] and base2[i]) > 0 then
putoutbit(1)
else
putoutbit(0);
end;
end else begin
for i := 1 to blacka[token][0] do begin
if (blacka[token][1] and base2[i]) > 0 then
putoutbit(1)
else
putoutbit(0);
end;
end;
end;
procedure insertlines(num : word);
var
i : word;
col : boolean;
begin
inc(lines, num);
for i := 1 to num do begin
addtostream(90, true); { white 1728 makeup code }
addtostream(0, true); { white 0 final code }
while outbufbit <> 4 do
putoutbit(0); { FILL so that EOL's are byte aligned }
addtostream(104, true); { eol token }
end;
end;
procedure makeendofpage(endoffax : boolean);
var
i, j, c : byte;
begin
if tlines < 65535 then
insertlines(1068-lines);
c := 7;
if endoffax then
c := 6;
inc(zfax.pgcount);
for i := 1 to c do begin
for j := 1 to 11 do
putoutbit(0);
putoutbit(1);
end;
lines := 0;
end;
function readbyte : byte;
begin
if pcxbufp >= bytesread then begin
if endofpage then begin
makeendofpage(true);
blockwrite(outfile, outbuf, outbufbyte, io);
write('Updating page count...');
close(outfile);
reset(outfile, 1); { update page count }
blockwrite(outfile, zfax, sizeof(zfax));
close(outfile);
close(pcxfile);
writeln('Conversion complete.');
halt;
end;
blockread(pcxfile, pcxbuf, sizeof(pcxbuf), bytesread);
loadingblock;
if filepos(pcxfile) = filesize(pcxfile) then
endofpage := true;
pcxbufp := 1;
end else
inc(pcxbufp);
readbyte := pcxbuf[pcxbufp];
end;
procedure countmh(count : word; var totalcount : word; var color : boolean; endofline : boolean);
begin
inc(totalcount, count);
if (endofline) and (totalcount <> 1728) then begin
inc(count, 1728-totalcount);
totalcount := 1728;
end;
if count > 63 then begin
addtostream((count div 64)+63, color); {makeup code}
addtostream(count mod 64, color); {final code}
end else
addtostream(count, color);
if endofline then begin
while outbufbit <> 4 do
putoutbit(0); { FILL so that EOL's are byte aligned }
addtostream(104, color); { FAXATREE #104 = EOL }
end;
color := not color;
end;
procedure cvtscanline(width : word; pcxkind : boolean);
var
bit, lastbit, bufbit, bufbyte, repeatbits, totalcount : word;
color : boolean;
begin
inc(lines);
color := true;
totalcount := 0;
bufbit := 1;
bufbyte := 1;
if imagebuf[bufbyte] and base2r[bufbit] > 0 then begin
lastbit := 1;
if pcxkind then
repeatbits := 1
else
repeatbits := 64;
end else begin
lastbit := 0;
if pcxkind then
addtostream(0, true)
else
countmh(63, totalcount, color, false); { margin four spaces }
color := false;
repeatbits := 1;
end;
repeat
inc(bufbit);
if bufbit > 8 then begin
bufbit := 1;
inc(bufbyte);
end;
if bufbyte > width then begin
countmh(repeatbits, totalcount, color, true);
exit;
end;
if (imagebuf[bufbyte] and base2r[bufbit]) > 0 then
bit := 1
else
bit := 0;
if bit = lastbit then
inc(repeatbits)
else begin
countmh(repeatbits, totalcount, color, false);
repeatbits := 1;
lastbit := bit;
end;
until(false);
end;
procedure processtextline;
var
i, j, ki, kj : byte;
begin
if tlines >= 66 then begin
tlines := 0;
makeendofpage(false);
insertlines(8);
end;
inc(tlines);
write('{p', zfax.pgcount+1, ', line ', tlines, '} ', #13);
inc(slen);
sarray[slen] := 32;
ki := 0;
for i := 0 to 15 do begin
kj := 1;
for j := 1 to slen do begin
imagebuf[kj] := fontset^[fontptr[sarray[j]]+ki+1];
imagebuf[kj+1] := fontset^[fontptr[sarray[j]]+ki];
inc(kj, 2);
end;
cvtscanline(slen+slen, false);
inc(ki, 2);
end;
slen := 0;
end;
begin
writeln('MAKEFAX 1.20, BGFAX PCX/ASCII to FAX converter utility.');
writeln('Copyright (C) 1994 B.J. Guillot. All Rights Reserved.');
if paramcount < 1 then
fatal('no file specified on command line');
writeln;
fn := paramstr(1);
write('Memory [', memavail div 1024, 'K] File ['+fn+'] ');
fopen := fn;
assign(pcxfile, fopen);
{$i-}
reset(pcxfile, 1);
io := ioresult;
if io > 0 then begin
writeln('I/O Error [', io, ']');
fatal('cannot open ['+fopen+']');
end;
{$i+}
assign(outfile, 'OUTPUT.FAX');
rewrite(outfile, 1);
fillchar(zfax, sizeof(zfax), #0);
zfax.header := 'ZyXEL';
zfax.offset := 0;
zfax.version := 2;
zfax.reserved := 0;
zfax.pgwidth := 1728;
zfax.pgcount := 0;
zfax.coding := 0; { 1d-low res }
move(zfax, outbuf, sizeof(zfax));
outbuf[sizeof(zfax)+1] := 0;
outbuf[sizeof(zfax)+2] := 128; { dummy EOL to start fax image }
blockwrite(outfile, outbuf, sizeof(zfax)+2, io);
blockread(pcxfile, pcxbuf, sizeof(pcxrec), bytesread);
move(pcxbuf, pcx, sizeof(pcxrec));
lines := 0;
p := 0;
bytesread := 0;
pcxbufp := 1;
endofpage := false;
outbufbit := 0;
outbufbyte := 1;
fillchar(outbuf, sizeof(outbuf), #0);
fillchar(imagebuf, sizeof(imagebuf), #0);
if pcx.zsoft = 10 then begin { PCX signature }
tlines := 65535; { non-text mode }
if (pcx.bitpix<>1) or (pcx.planes<>1) then
fatal('Only 2-color PCX files can be converted');
writeln('Size [', filesize(pcxfile) div 1024, 'K]');
writeln('Bits Wide [', pcx.dimens[3]+1,
'] Scan Lines [', pcx.dimens[4]+1, ']');
if pcx.dimens[3] > 1727 then
fatal('Page width must be 1728 bits or shorter');
repeat
v := readbyte;
if (v and 192) = 192 then begin { repition }
r := v xor 192;
v := r; { reset v as the real count }
j := readbyte; { read the actual count }
if r + p > pcx.byteline then begin
r := pcx.byteline-p;
fillchar(imagebuf[p+1], r, j);
cvtscanline(pcx.byteline, true);
r := v - r;
fillchar(imagebuf, r, j);
p := r;
end else begin
fillchar(imagebuf[p+1], r, j);
inc(p, v);
end;
end else begin
inc(p);
imagebuf[p] := v;
end;
if p = pcx.byteline then begin
cvtscanline(pcx.byteline, true);
fillchar(imagebuf, sizeof(imagebuf), #0);
p := 0;
end;
until(false);
end else begin { ASCII file }
tlines := 0;
for v := 0 to 255 do
fontptr[v] := v*32;
fopen := 'BGFAX.FNT';
assign(fontfile, fopen);
{$i-}
reset(fontfile, 1);
io := ioresult;
if io > 0 then begin
writeln('I/O error [', io, ']');
fatal('cannot open font file ['+fopen+']');
end;
{$i+}
new(fontset);
blockread(fontfile, fontset^, filesize(fontfile), j);
close(fontfile);
close(pcxfile);
reset(pcxfile, 1);
slen := 0;
pcx.byteline := 216;
writeln;
insertlines(8);
repeat
v := readbyte;
if (v = 13) then begin
v := readbyte; { a linefeed }
processtextline;
end else if slen > 99 then begin {allows 100 char width}
inc(slen);
sarray[slen] := v;
processtextline;
end else begin
inc(slen);
sarray[slen] := v;
end;
until(false);
end;
end.